Cream of the Crop 21/Cream of the Crop 21 (Terry Blount) (October 1996).iso/os2/freetype.zip/testtime.pas

Pascal/Delphi Source File | 1996-09-07 | 6KB | 320 lines

program TrueType_Time;

uses Crt, Dos, TTDisp, TTTypes, TTCalc, TTTables, Raster;

{ $DEFINE DEBUG}
{ $DEFINE VISUAL}

const
  Precis  = 64;
  Precis2 = Precis div 2;

  PrecisAux = 1024;

  Centre_X : int = 320;
  Centre_Y : int = 225;

  Profile_Buff_Size = 64000;

var

  Font_Buffer : PStorage;

  curGlyphContours : PGlyphContours;

  num_pts : word;
  num_ctr : word;

  glyfArray : word;

  epts_ctr : PShortArray;

  xCoord : PStorage;
  yCoord : PStorage;
  Flag   : PByteArray;

  ymin, ymax, xmax, xmin, xsize : longint;
  res,  resB                    : int;

  resR : real;

  resX, resY : real;

  LastX, LastY : FixedPoint;

  numPoints, numContours : int;

  curGlyph        : ^TGlyph;
  curGlyphContour : PGlyphContour;

  Bit : TRasterBlock;

  yCur : integer;

  ScXMax, ScYMax,
  CntX, CntY : Integer;

  Rotation : int;  (* Angle modulo 1024 *)


Procedure InitRows;
var
  i: integer;
  P: Pointer;
begin

  Bit.rows  := 450;
  Bit.cols  := 80;
  Bit.width := 640;
  Bit.flow  := TTFlowDown;
  Bit.size  := 80*450;

  GetMem( Bit.buffer, Bit.size );
  if Bit.buffer = NIL then
   begin
    Writeln('ERREUR:InitRows:Pas assez de mémoire pour le BitMap');
    halt(1);
   end;

  GetMem( P, Profile_Buff_Size );
  if P=nil then
   begin
    writeln('ERREUR:InitRows:Pas assez de mémoire pour le buffer profils');
    Halt(2);
   end;

  InitRasterizer( Bit, P, Profile_Buff_Size );

  FillChar( Bit.Buffer^, Bit.Size, 0 );
end;


Procedure Clear_Buffer;
begin
  FillChar( Bit.Buffer^, Bit.Size, 0 );
end;

Procedure ClearData;
var i: integer;
begin
  FreeMem( XCoord, SizeOf(FixedPoint)*numPoints );
  FreeMem( YCoord, SizeOf(FixedPoint)*numPoints );

  FreeMem( Flag, numPoints );
end;


Function LoadTrueTypeChar( idx : integer ) : boolean;
var
  off    : longint;
  x, y   : Real;
  i, szp : integer;
  j      : word;
  c, ct  : byte;
  Gl     : TGlyph;
  EM     : Word;
  CR, SR : Real;

begin
  LoadtrueTypeChar:=FALSE;
  if (idx<0) or (idx>=Num_Glyphs) then exit;

  CurGlyph := @Glyphs^[idx];
  Gl       := CurGlyph^;

  numPoints        := Gl.numberOfPoints;
  numContours      := Gl.numberOfContours;
  curGlyphContours := Gl.Contours;

  GetMem( XCoord, SizeOf(Fixed)*numPoints );
  GetMem( YCoord, SizeOf(Fixed)*numPoints );
  GetMem( Flag, numPoints );

  xMin := Gl.xMin;
  xMax := Gl.xMax;
  yMin := Gl.yMin;
  yMax := Gl.yMax;

  EM := Font_Header^.UnitsPerEM;

  dec( xMax, xMin );
  dec( yMax, yMin );

  dec ( res );
  resR := res/EM/2;

  xmax := trunc( xmax*resR+0.5 );
  ymax := trunc( ymax*resR+0.5 );

  CR := Cos( Rotation*Pi/512 );
  SR := Sin( Rotation*Pi/512 );

  for j:=0 to numPoints-1 do
   begin

    x := Gl.Points^[j].x * ( res / EM );
    y := Gl.Points^[j].y * ( res / EM );

    off := Trunc( Precis*( CR*(x-xmax) + SR*(y-ymax) ) );
    XCoord^[j] := Precis*( Centre_X + off div Precis ) + Precis2;

    off := Trunc( Precis*( - SR*(x-xmax) + CR*(y-ymax) ) );
    YCoord^[j] := Precis*( Centre_Y + off div Precis ) + Precis2;

    Flag^[j] := Gl.Points^[j].flag;
   end;

  inc ( res );
  resR := 1/res;

  xsize := ( xmax + 7 ) div 8;

  LoadTrueTypeChar:=TRUE;
end;


function Get_Time : LongInt;
var
  heure,
  min,
  sec,
  cent :
{$IFDEF OS2}
  longint;
{$ELSE}
  word;
{$ENDIF}
begin
  GetTime( heure, min, sec, cent );
  Get_Time := 6000*longint(min) + 100*longint(sec) + cent;
end;




function ConvertRaster : boolean;
var
  B : Array[0..128] of Integer;
  i : integer;
  G : TGlyphRecord;
begin

  for i := 0 to numContours-1 do
    B[i] := CurGlyphContours^[i].Finish;

  G.Outlines  := numContours;
  G.OutStarts := @B;
  G.Points    := numPoints;
  G.XCoord    := XCoord;
  G.YCoord    := YCoord;
  G.Flag      := Flag;

  ConvertRaster := RenderGlyph( G, res, res );
end;




var i: integer;
    C : Char;

    T : longint;

    Filename : String;

    Fail : Int;


begin
  GetMem    ( Font_Buffer, 64000 );
  InitBuffer( Font_Buffer^, 64000 );

  curGlyphContours:=NIL;

  num_pts   :=0;
  num_ctr   :=0;

  xCoord  :=NIL;
  yCoord  :=NIL;
  Flag    :=NIL;

  for i:=0 to ParamCount do Writeln(ParamStr(i));

  If paramCount<>1 then
   begin
    Writeln('Usage : ',paramStr(0),' FontName[.TTF]');
    Halt(1);
   end;

  Filename := ParamStr(1);
  if Pos('.',FileName)=0 then FileName:=FileName+'.TTF';
  if not Open_TrueType_File(Filename ) then
   begin
    Writeln('Erreur, le fichier ',ParamStr(1),' n''a pu être ouvert');
    Halt(1);
   end;

  res  := 450;
  resB := (res+7) div 8;

  Rotation := 0;

  Load_TrueType_Tables;

  Load_TrueType_MaxProfile;

  if Load_TrueType_Glyphs=0 then
   begin
    Writeln('Problème lors du chargement des glyphes');
    Halt(1);
   end;

  InitRows;

  res  := 850;
  Fail := 0;

{$IFDEF VISUAL}
  SetGraphScreen;
{$ENDIF}

  T := Get_Time;

  for i:=0 to Num_Glyphs-1 do
   begin
    if LoadtrueTypeChar(i) then
     begin

{$IFDEF VISUAL}

      if ConvertRaster then

          Display( Bit.Buffer^, 450, 80 )
      else
        inc(Fail);

      Clear_Buffer;
{$ELSE}
      if not ConvertRaster then
        inc(Fail);
{$ENDIF}
      ClearData;
     end;
   end;

{$IFDEF VISUAL}
  RestoreScreen;
{$ENDIF}
  Write  (' Temps écoulé : ');

  T := Get_Time - T;
  if T < 0 then T := T + 100*60*60;

  writeln('Temps : ', T/100:0:2,' s');
  writeln('Echecs: ',Fail );

  Close_TrueType_File;
  Readkey;
end.